home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / misc / worldmap / mapvu20 / qslide.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-11  |  8.6 KB  |  236 lines
  1. Program qslide; { display series of pictures from disk                       }
  2. { as produced by, e.g., MapView 2.0 or later                                 }
  3. { Freeware by Gisbert W.Selke, 11 Jan 1989. TurboPascal 4.0/5.0              }
  4. { With a hint from and additional error handling by Stefan Kaufmann.         }
  5.  
  6. {$R-,S-,I+,D-,F-,V-,B-,N-,L+ }
  7. {$M 1300,0,655360 }
  8. { If you change and recompile, better first set $S+ - stack size has been    }
  9. { optimized.                                                                 }
  10.  
  11.   Uses Graph, CRT;
  12.  
  13.   Const defext = '.PIC';
  14.         hercsize = 32500;  { Hercules screen size }
  15.         cgasize  =  8000;  { CGA      screen size }
  16.         maxpics = 75;
  17.         thisversion = 2;
  18.         version = '1.1';
  19.   crnotice : string[50] = 'Freeware by TapirSoft Gisbert W.Selke, 11 Jan 1989';
  20.  
  21.   Type scrf    = File;
  22.        picdesc = Record                   { screen file header record }
  23.                    versionc, followc : byte;
  24.                    grdriverc, grmodec : integer;
  25.                    sizec : word;
  26.                    xminc, yminc : integer;
  27.                  End;
  28.  
  29.   Var grdriver, grmode : integer;
  30.       minfree : longint;
  31.       psize, clearct, readct, wait, repts, repct, picds, nread, i : word;
  32.       ch : char;
  33.       curpic, lastpic, maxlastpic : byte;
  34.       finish, first, dowait, mono, keywait : boolean;
  35.       monoscreen   : word Absolute $B000:$0000;
  36.       colourscreen : word Absolute $B800:$0000;
  37.       picarr : Array [1..maxpics] Of pointer;
  38.       filename : string[63];
  39.       screenfile : scrf;
  40.       picd : picdesc;
  41.  
  42.   Procedure FastKey; InLine
  43.   { fast way of testing for a key pressed                                    }
  44.   { nicked from PC Magazine, 26 Jan 1988                                     }
  45.     ($31/$C0/                         { XOR AX,AX }
  46.      $8E/$C0/                         { MOV ES,AX }
  47.      $26/$A1/$1A/$04/                 { MOV AX,ES:[041A] }
  48.      $26/$3B/$06/$1C/$04/             { CMP AX,ES:[041C] }
  49.      $74/$03);                        { JZ  $+3 }
  50.  
  51.  
  52.   Procedure abort(t : string; i : byte);
  53.   { display an error message and abort                                       }
  54.   Begin                                                              { abort }
  55.     RestoreCRTMode;
  56.     writeln(t);
  57.     Halt(i);
  58.   End;                                                               { abort }
  59.  
  60.   Procedure init;
  61.   { process command line arguments                                           }
  62.     Var i : byte;
  63.         t : string[63];
  64.   Begin                                                               { init }
  65.     If ParamCount = 0 Then
  66.     Begin
  67.       writeln('Usage: qslide <filename>[.<ext>] [/D<delay>][/R<repetitions]');
  68.       Halt(1);
  69.     End;
  70.     wait  := 0;
  71.     repts := 1;
  72.     keywait := False;
  73.     filename := '';
  74.     For i := 1 To ParamCount Do
  75.     Begin
  76.       t := ParamStr(i);
  77.       If (t[1] = '/') Or (t[1] = '-') Then
  78.       Begin
  79.         If Length(t) >=3 Then
  80.         Begin
  81.           Case UpCase(t[2]) Of
  82.             'D' : Begin
  83.                     val(copy(t,3,255),minfree,grdriver);
  84.                     If (grdriver = 0) And (minfree >=0)
  85.                         And (minfree <= MaxInt) Then wait := minfree
  86.                       Else abort('Illegal /D specification',4);
  87.                     If wait = 0 Then wait := 2*MaxInt
  88.                                 Else wait := (wait+5) Div 10;
  89.                   End;
  90.             'R' : Begin
  91.                     val(copy(t,3,255),minfree,grdriver);
  92.                     If (grdriver = 0) And (minfree >=0)
  93.                         And (minfree <= MaxInt) Then repts := minfree
  94.                       Else abort('Illegal /R specification',4);
  95.                   End;
  96.             Else abort('Illegal command line option',4);
  97.           End;
  98.         End Else
  99.         Begin
  100.           If (Length(t) = 2) And (UpCase(t[2]) = 'K') Then keywait := True
  101.             Else abort('Illegal command line option',4);
  102.         End;
  103.       End Else
  104.       Begin
  105.         If filename <> '' Then abort('Multiple input files not supported',4);
  106.         filename := ParamStr(i);
  107.       End;
  108.     End;
  109.     If filename = '' Then abort('No input file specified',4);
  110.     If Pos('.',filename) = 0 Then filename := filename + defext;
  111.     dowait := wait > 0;
  112.     ch := #0;
  113.   End;                                                                { init }
  114.  
  115.   Procedure leaveprog;
  116.   { leave the programme orderly, if certain conditions hold                  }
  117.   Begin                                                          { leaveprog }
  118.     If ch <> #27 Then ch := ReadKey;
  119.     If (Not keywait) Or (ch In [#3,#27,'Q','q']) Then
  120.     Begin
  121.       CloseGraph;
  122.       writeln('QSLIDE ',version,'  --  ',crnotice);
  123.       If clearct = 0 Then maxlastpic := lastpic;
  124.       If Not first Then write('Number of screens in file: ',readct,'. ');
  125.       writeln('Maximum number of screens stored: ',maxlastpic,'.');
  126.       If clearct = 0 Then minfree := MaxAvail;
  127.       writeln('Minimum memory available was about ',minfree,' bytes.');
  128.       writeln('Buffer was cleared ',clearct,' times.');
  129.       If KeyPressed Then curpic := ord(ReadKey);
  130.       Halt;
  131.     End;
  132.   End;                                                           { leaveprog }
  133.  
  134.   Procedure dodelay;
  135.   { waits <wait> times 10 milliseconds or until keypress                     }
  136.   Begin                                                            { dodelay }
  137.     i := 0;
  138.     ch := #0;
  139.     Repeat
  140.       Delay(10);
  141.       Inc(i);
  142.       Fastkey;
  143.       leaveprog;
  144.     Until (ch <> #0) Or (i >= wait);
  145.   End;                                                             { dodelay }
  146.  
  147. Begin                                                                 { main }
  148.   writeln('QSLIDE ',version,'  --  ',crnotice);
  149.   init;
  150.   CheckBreak := False;
  151.   Assign(screenfile,filename);
  152.   {$I- } Reset(screenfile,1);  {$I+ }
  153.   If IOResult <> 0 Then abort('Cannot open input file ' + filename,3);
  154.   grdriver := Detect;
  155.   InitGraph(grdriver,grmode,'');
  156.   minfree := GraphResult;
  157.   If minfree <> 0 Then abort(GraphErrorMsg(minfree),1);
  158.   { detect Graph-Error as soon as possible!! Stefan Kaufmann. }
  159.   If (grdriver <> CGA) And (grdriver <> HercMono) Then
  160.                       abort('Works only for CGA and Hercules adapters',1);
  161.   mono := grdriver = HercMono;
  162.   picds := SizeOf(picdesc);
  163.   If mono Then psize := hercsize Else psize := cgasize;
  164.   lastpic := 0;
  165.   maxlastpic := 0;
  166.   clearct := 0;
  167.   If repts = 0 Then repct := 1 Else repct := 0;
  168.   readct := 0;
  169.   first := True;
  170.   Repeat
  171.     Repeat
  172.       If eof(screenfile) Then finish := True
  173.       Else
  174.       Begin
  175.         BlockRead(screenfile,picd,picds,nread);
  176.         If nread <> picds Then abort('Illegal size record in file',2);
  177.         With picd Do
  178.         Begin
  179.           If versionc > thisversion Then abort('Illegal pic file version',2);
  180.           If (grdriver <> grdriverc) Or (grmode <> grmodec) Then
  181.              abort('Incompatible graphics mode in file',2);
  182.           If (MaxAvail < sizec) Or (lastpic >= Pred(maxpics)) Then
  183.           Begin
  184.             minfree := MaxAvail;
  185.             For curpic := lastpic DownTo 1 Do
  186.                            FreeMem(picarr[curpic],psize);
  187.             If lastpic > maxlastpic Then maxlastpic := lastpic;
  188.             lastpic := 0;
  189.             Inc(clearct);
  190.           End;
  191.           Inc(lastpic);
  192.           GetMem(picarr[lastpic],psize);
  193.           BlockRead(screenfile,picarr[lastpic]^,sizec,nread);
  194.           If nread <> sizec Then abort('Illegal pic size in file',2);
  195.           finish := False;
  196.           PutImage(xminc,yminc,picarr[lastpic]^,NormalPut);
  197.           If followc = 0 Then
  198.           Begin
  199.             If mono Then Move(monoscreen,picarr[lastpic]^,psize)
  200.                     Else Move(colourscreen,picarr[lastpic]^,psize);
  201.             If dowait Then dodelay;
  202.             If first Then Inc(readct);
  203.           End Else
  204.           Begin
  205.             FreeMem(picarr[lastpic],psize);
  206.             Dec(lastpic);
  207.           End;
  208.         End;
  209.       End;
  210.       FastKey;
  211.       leaveprog;
  212.     Until finish;
  213.     first := False;
  214.     Reset(screenfile,1);
  215.     If repts <> 0 Then Inc(repct);
  216.   Until (repct = repts) Or (clearct = 0);
  217.   Close(screenfile);
  218.   If clearct = 0 Then
  219.   Begin
  220.     While repct <> repts Do
  221.     Begin
  222.       If repct <> 0 Then Inc(repct);
  223.       For curpic := 1 To lastpic Do
  224.       Begin
  225.         If mono Then Move(picarr[curpic]^,monoscreen,psize)
  226.                 Else Move(picarr[curpic]^,colourscreen,psize);
  227.         If dowait Then dodelay;
  228.         FastKey;
  229.         leaveprog;
  230.       End;
  231.     End;
  232.   End;
  233.   ch := #27;
  234.   leaveprog;
  235. End.
  236.